home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / CGIshell 1.3.2 / Pocket 6.5 / Examples / Eliza.pf < prev    next >
Text File  |  1995-11-11  |  13KB  |  391 lines
  1. ( Eliza 10/22/95  20:24:17)
  2. ( To load this program: )
  3. (  put this file, strings.pf, datafiles.pf and Pocket Forth )
  4. (  into the same folder, then drag this file onto the icon  )
  5. (  of Pocket Forth to open this file. )  0 28 +md !
  6.  
  7. forget task : task ;
  8. \ --> debugging.pf
  9. --> strings.pf
  10. --> datafiles.pf
  11.  
  12. \ ------------------------------------------------------------
  13. \                            Part 0
  14. \ ----------------------additional string stuff---------------
  15.  
  16. : -$TRAILING ( string -- ) \ remove trailing spaces.
  17.     BEGIN dup length 1- + dup c@ 32 =
  18.     WHILE 0 over c! REPEAT drop ;
  19.  
  20. : -$LEADING ( string -- )  \ remove leading space
  21.     dup BEGIN dup c@ 32 = WHILE 1+ REPEAT
  22.     over - over length swap - $right ;
  23.  
  24. $constant DSPACE   }  $constant SP  }
  25. : -$DOUBLESPACE ( string -- ) \ remove double spaces.
  26.     BEGIN
  27.       dup here 512 + $copy
  28.       dup dspace sp $replace
  29.       dup here 512 + $=
  30.     UNTIL drop ;
  31.  
  32. : -$MARKERS ( string -- ) \ remove @ and * markers and replace with spaces
  33.     dup length 0 DO
  34.       dup r + c@ dup 64 = swap 42 = or IF
  35.       dup r + 32 swap c! THEN
  36.     LOOP -$doublespace ;
  37.  
  38. : $CLEANUP ( string -- ) dup -$trailing dup -$leading -$markers ;
  39.  
  40. : -$PUNCTUATION ( string -- ) \ remove ., ! and ?
  41.     dup -$trailing
  42.     dup  length 1- 2dup + c@
  43.     dup 33 = swap  dup 46 = swap  63 = or or IF
  44.     + 0 swap c! ELSE 2drop THEN ;
  45.  
  46. \ Put a space at both ends of a string.
  47. : $PREP ( string -- ) \ prepare a string for analysis
  48.     dup -$punctuation
  49.     dup $upper
  50.     here over length 3 + 0 fill
  51.     32 here c!
  52.     dup here $+
  53.     dup length here + 1+ 32 swap c!
  54.     here swap $copy ;
  55.  
  56. \ ----------------------some file stuff-------------------
  57.  
  58. 13 constant [RET]
  59. : @LINE ( string -- ) \ set string to a line from an open file
  60.     0 swap dup [ret] cread 1- + c! ;
  61.  
  62. : !LINE ( string -- ) \ send a string to a file
  63.     BEGIN dup c@  WHILE dup c@ putchr  1+  REPEAT drop ;
  64.  
  65. \ --------------------and some other stuff------------------
  66.  
  67. 3 4 $array OFF  0 off ${ OFF}  1 off ${ off}  2 off ${ Off}
  68. : ?ON ( string -- flag ) \ is the word off not included?
  69.     0 swap 3 0 DO dup r off $find rot or swap LOOP drop 0= ;
  70.  
  71. \ random numbers with no repeats
  72. : RANDOM ( n -- n' ) 0 >r ,$ A861 r>  swap 32768 */ abs ;
  73. variable RN1  4 rn1 !  \ the last number picked
  74. : RAND ( n -- n' ) \ never pick the same number twice in a row
  75.    BEGIN dup random dup rn1 @ =  \ scale to zero to n range
  76.    WHILE drop REPEAT swap drop dup rn1 ! ;
  77.  
  78. \ ------------------------------------------------------------
  79. \                            Part 1
  80. \ --------------Substitute one word for another---------------
  81.  
  82. 32 12 $array OPS  \ opposite forms
  83.  
  84. \ When you say:            Webliza sez:
  85. 00 ops ${  MOM }        01 ops ${  MOTHER }
  86. 02 ops ${  DAD }        03 ops ${  FATHER }
  87. 04 ops ${  DREAMS }        05 ops ${  DREAM }
  88. 06 ops ${  I }            07 ops ${  YOU@ }
  89. 08 ops ${  YOU }        09 ops ${  I }
  90. 10 ops ${  ME }            11 ops ${  YOU }
  91. 12 ops ${  MY }            13 ops ${  YOUR* }
  92. 14 ops ${  YOUR }        15 ops ${  MY }
  93. 16 ops ${  MYSELF }        17 ops ${  YOURSELF* }
  94. 18 ops ${  YOURSELF }    19 ops ${  MYSELF }
  95. 20 ops ${  I'M }        21 ops ${  YOU'RE* }
  96. 22 ops ${  YOU'RE }        23 ops ${  I'M }
  97. 24 ops ${  AM }            25 ops ${  ARE@ }
  98. 26 ops ${  WERE }        27 ops ${  WAS }
  99. 28 ops ${  IM }            29 ops ${  YOU'RE* }
  100. 30 ops ${  YOURE }        31 ops ${  I'M }
  101.  
  102. 32 constant #OPS  \ the number of words
  103.  
  104. : $SUBSTITUTE ( string -- )
  105.     #ops 0 DO
  106.         BEGIN
  107.             dup here 160 + $copy
  108.             dup  r ops  r 1+ ops $replace
  109.             dup here 160 + $=
  110.         UNTIL
  111.     2 +LOOP drop ;
  112.  
  113. \ ------------------------------------------------------------
  114. \                           Part 2
  115. \ -----------------------the keywords-------------------------
  116.  
  117. variable #KEYWORDS  81 #keywords ! \ number of lines in .keys file
  118. 30 constant KWSIZE   \ maximum length of a keyword
  119.  
  120. #keywords @  kwsize 8 - $array KEYS
  121.  
  122. 1  keys ${ COMPUTER}
  123. 2  keys ${ INTERNET}
  124. 3  keys ${  NAME }
  125. 4  keys ${ ALIKE}
  126. 5  keys ${  LIKE }
  127. 6  keys ${  SAME }
  128. 7  keys ${ YOU@ REMEMBER}
  129. 8  keys ${ DO I REMEMBER}
  130. 9  keys ${ YOU@ DREAMED}
  131. 10  keys ${  DREAM }
  132. 11  keys ${  IF }
  133. 12  keys ${ EVERYBODY}
  134. 13  keys ${ EVERYONE}
  135. 14  keys ${ NOBODY}
  136. 15  keys ${ NO ONE}
  137. 16  keys ${ WAS YOU@ }
  138. 17  keys ${ YOU@ WAS}
  139. 18  keys ${ WAS I}
  140. 19  keys ${ YOUR* MOTHER}
  141. 20  keys ${ YOUR* FATHER}
  142. 21  keys ${ YOUR* SISTER}
  143. 22  keys ${ YOUR* BROTHER}
  144. 23  keys ${ YOUR* WIFE}
  145. 24  keys ${ YOUR* HUSBAND}
  146. 25  keys ${ YOUR* CHILDREN}
  147. 26  keys ${ YOUR* }
  148. 27  keys ${ ALWAYS}
  149. 28  keys ${ ARE I}
  150. 29  keys ${ ARE@ YOU@}
  151. 30  keys ${  HOW }
  152. 31  keys ${ BECAUSE}
  153. 32  keys ${ CAN I}
  154. 33  keys ${ CAN YOU@ }
  155. 34  keys ${ CERTAINLY}
  156. 35  keys ${ DEUTCH}
  157. 36  keys ${ ESPANOL}
  158. 37  keys ${ FRANCAIS}
  159. 38  keys ${ HELLO}
  160. 39  keys ${ I REMIND YOU OF}
  161. 40  keys ${ I ARE}
  162. 41  keys ${ I'M}
  163. 42  keys ${ ITALIANO}
  164. 43  keys ${ MAYBE}
  165. 44  keys ${  MY }
  166. 45  keys ${  NO }
  167. 46  keys ${ PERHAPS}
  168. 47  keys ${ SORRY}
  169. 48  keys ${ WHAT }
  170. 49  keys ${ WHEN }
  171. 50  keys ${ WHY DON'T I}
  172. 51  keys ${ WHY CAN'T YOU@ }
  173. 52  keys ${ YES}
  174. 53  keys ${ YOU@ WANT}
  175. 54  keys ${ YOU@ NEED}
  176. 55  keys ${  ARE }
  177. 56  keys ${  I }
  178. 57  keys ${ YOU@ ARE@ SAD}
  179. 58  keys ${ YOU'RE* SAD}
  180. 59  keys ${ YOU@ ARE@ DEPRESSED}
  181. 60  keys ${ YOU'RE* DEPRESSED}
  182. 61  keys ${ YOU@ ARE@ SICK}
  183. 62  keys ${ YOU'RE* SICK}
  184. 63  keys ${ YOU@ ARE@ HAPPY}
  185. 64  keys ${ YOU'RE* HAPPY}
  186. 65  keys ${ YOU@ ARE@ ELATED}
  187. 66  keys ${ YOU'RE* ELATED}
  188. 67  keys ${ YOU@ ARE@ GLAD}
  189. 68  keys ${ YOU'RE* GLAD}
  190. 69  keys ${ YOU@ ARE@ BETTER}
  191. 70  keys ${ YOU'RE* BETTER}
  192. 71  keys ${ YOU@ FEEL YOU@ }
  193. 72  keys ${ YOU@ THINK YOU@ }
  194. 73  keys ${ YOU@ BELIEVE YOU@ }
  195. 74  keys ${ YOU@ WISH YOU@ }
  196. 75  keys ${  YOU@ ARE@ }
  197. 76  keys ${ YOU'RE* }
  198. 77  keys ${ YOU@ CAN'T}
  199. 78  keys ${ YOU@ CANNOT}
  200. 79  keys ${ YOU@ DON'T}
  201. 80  keys ${ YOU@ FEEL}
  202. 0 81 keys c! ( )
  203.  
  204. create KEYMAP
  205.   (  1: )     1 ,   1 ,   2 ,   3 ,   3 ,   3 ,   4 ,   5 ,   6 ,
  206.   ( 10: )     7 ,   8 ,   9 ,   9 ,   9 ,   9 ,  10 ,  11 ,  12 ,
  207.   ( 19: )    13 ,  13 ,  13 ,  13 ,  13 ,  13 ,  13 ,  14 ,  15 ,
  208.   ( 28: )    16 ,  18 ,  25 ,  19 ,  20 ,  21 ,  22 ,  23 ,  23 ,
  209.   ( 37: )    23 ,  24 ,  23 ,  26 ,  26 ,  23 ,  28 ,  29 ,  30 ,
  210.   ( 46: )    28 ,  31 ,  25 ,  25 ,  32 ,  33 ,  22 ,  34 ,  34 ,
  211.   ( 55: )    17 ,  27 ,  35 ,  35 ,  35 ,  35 ,  35 ,  35 ,  36 ,
  212.   ( 64: )    36 ,  36 ,  36 ,  36 ,  36 ,  36 ,  36 ,  37 ,  37 ,
  213.   ( 73: )    37 ,  37 ,  38 ,  38 ,  39 ,  39 ,  40 ,  41 ,   0 , 
  214.  
  215. kwsize $variable KEYWORD  \ the selected keyword
  216. kwsize $variable TKW       \ temporary keyword
  217.  
  218. $constant KWFILE eliza.keys}  kwfile >count
  219.  
  220. 80 $variable INSTRING  \ the input string
  221. 80 $variable MYSTRING
  222. 80 $variable RTSTRING
  223.  
  224. \ ---------------------------find keyword----------------------
  225.  
  226. : !RTSTRING ( pos -- ) \ set rtstring to instring right of keyword
  227.     instring rtstring $copy
  228.     rtstring dup length rot keyword length 1- + - $right
  229.     rtstring $cleanup ;
  230.  
  231. variable TAB  0 tab !  9 tab c!  \ this is really a string :)
  232. variable KNUMBER                  \ the number of the keyword
  233. : @KEYWORD ( -- keynumber ) \ SET VARIABLES: keyword & rtstring
  234.     0 knumber !
  235.     kwfile open  kwsize !size     \ open the keyword file
  236.     tkw dup @line dup >count number IF #keywords ! THEN  \ **
  237.     #keywords @ 0 DO
  238.       tkw @line
  239.       tkw keyword $copy              \ copy line to keyword
  240.       keyword dup tab $find 1- $left  \ clip key line to the keyword part
  241.       instring keyword $find  ?dup IF           \ find keyword in instring
  242.         tkw dup length over tab $find - $right   \ clip to the number part
  243.         tkw dup >count number IF  knumber ! THEN  \ put value into knumber
  244.         !rtstring LEAVE                            \ set rtstring
  245.       THEN
  246.     LOOP close
  247.     knumber @ ;
  248.  
  249. \ Handle special cases.
  250. : ?SPECIAL ( keyword.number -- response.number )
  251.      instring dspace $= IF drop 42 THEN  \ blank input
  252.  
  253.      dup 0= IF               \  no key word found in input
  254.        mystring length IF     \  previous reference to 'my...'
  255.          drop  5 rand 48 +     \  bring up previous reference to 'my...'
  256.        ELSE  drop  5 rand 43 +  \ 'please go on', etc. type responses
  257.      THEN THEN
  258.  
  259.      dup 14 = IF rtstring mystring $copy THEN  \ SET $VARIABLE: mystring
  260.  
  261.      \ Put additional special actions here. \
  262.     ;
  263.  
  264. \ ------------------------------------------------------------
  265. \                            Part 3
  266. \ --------------------------respond----------------------------
  267.  
  268. 54 60 $array responses \ the responses
  269.  
  270. 00 responses ${ DANGER, DANGER, WILL ROBINSON!}
  271. 01 responses ${ DOES THE INTERNET WORRY YOU?}
  272. 02 responses ${ NO NAMES, PLEASE.}
  273. 03 responses ${ HOW'S THAT?}
  274. 04 responses ${ DO YOU THINK ABOUT ^0 OFTEN?}
  275. 05 responses ${ DID YOU THINK I WOULD FORGET ^0?}
  276. 06 responses ${ REALLY, ^0?}
  277. 07 responses ${ WHAT DOES THAT DREAM SUGGEST TO YOU?}
  278. 08 responses ${ DO YOU THINK IT'S LIKELY THAT IF ^0?}
  279. 09 responses ${ REALLY, ^1?}
  280. 10 responses ${ WHAT IF YOU WERE ^0?}
  281. 11 responses ${ WERE YOU REALLY?}
  282. 12 responses ${ DO YOU WANT TO BELIEVE I WAS ^0?}
  283. 13 responses ${ TELL ME MORE ABOUT YOUR FAMILY.}
  284. 14 responses ${ YOUR ^0...}
  285. 15 responses ${ GIVE ME A SPECIFIC EXAMPLE?}
  286. 16 responses ${ WHY DO YOU CARE IF I AM ^0 OR NOT?}
  287. 17 responses ${ DID YOU THINK THEY MIGHT NOT BE ^0?}
  288. 18 responses ${ DO YOU BELIEVE YOU ARE ^0?}
  289. 19 responses ${ THATS NOT THE REAL REASON, IS IT?}
  290. 20 responses ${ YOU BELIEVE I CAN ^0, DON'T YOU?}
  291. 21 responses ${ WHETHER OR NOT YOU CAN ^0 DEPENDS MORE ON YOU THAN ON ME.}
  292. 22 responses ${ YOU SEEM SURE.}
  293. 23 responses ${ SORRY, I CAN ONLY UNDERSTAND ENGLISH.}
  294. 24 responses ${ HOW DO YOU DO.}
  295. 25 responses ${ WHY DO YOU ASK?}
  296. 26 responses ${ WHAT MAKES YOU THINK I AM ^0?}
  297. 27 responses ${ WE'RE TALKING ABOUT YOU, NOT ME.}
  298. 28 responses ${ YOU DON'T SEEM SO SURE.}
  299. 29 responses ${ WHY ARE YOU WORRIED ABOUT MY ^0?}
  300. 30 responses ${ ARE YOU SAYING `NO' JUST TO BE CONTRARY?}
  301. 31 responses ${ OH PLEASE, DON'T APPOLOGIZE.}
  302. 32 responses ${ DO YOU THINK I DON'T ^0?}
  303. 33 responses ${ DO YOU THINK YOU SHOULD BE ABLE TO ^0?}
  304. 34 responses ${ WOULD IT BE COOL IF YOU GOT ^0?}
  305. 35 responses ${ SO SORRY THAT ^1 ^0.}
  306. 36 responses ${ I AM GLAD THAT ^1 ^0?}
  307. 37 responses ${ DO YOU REALLY THINK SO?}
  308. 38 responses ${ IS IT BECAUSE YOU ARE ^0 THAT YOU CAME TO ME?}
  309. 39 responses ${ WHAT MAKES YOU THINK THAT YOU CAN'T ^0?}
  310. 40 responses ${ DON'T YOU REALLY ^0?}
  311. 41 responses ${ TELL ME MORE ABOUT THOSE FEELINGS.}
  312. 42 responses ${ DON'T BE SHY, I WON'T BITE!}
  313. 43 responses ${ TELL ME MORE.}
  314. 44 responses ${ DO GO ON...}
  315. 45 responses ${ PLEASE ELABORATE ON THAT POINT.}
  316. 46 responses ${ WHAT ELSE?}
  317. 47 responses ${ OH?...}
  318. 48 responses ${ EARLIER YOU SAID YOUR ^2...}
  319. 49 responses ${ GO BACK TO YOUR ^2 AND ELABORATE.}
  320. 50 responses ${ WHAT DID YOU MEAN WHEN YOU SAID YOUR ^2?}
  321. 51 responses ${ I WANT TO HEAR MORE ABOUT YOUR ^2.}
  322. 52 responses ${ LETS TALK ABOUT YOUR ^2.}
  323.  
  324. $constant ^0 ^0}
  325. $constant ^1 ^1}
  326. $constant ^2 ^2}
  327.  
  328. 160 $variable RESPONSE
  329.  
  330. $constant RSFILE eliza.responses}  rsfile >count
  331.  
  332. variable #RESPONSES  0 #responses !
  333.  
  334. \ -----------------build the response string------------------
  335.  
  336. : RESPOND ( -- ) \ set variables: RESPONSE and #RESPONSES
  337.     instring $prep
  338.     instring $substitute
  339.     @keyword ?special     ( -- key_number )
  340.  
  341.     rsfile open
  342.     1+ 0 DO response @line LOOP  \ put line in RESPONSE variable.
  343.     close
  344.  
  345.     response ^0 rtstring $replace
  346.     response ^1 keyword  $replace
  347.     response ^2 mystring $replace
  348.  
  349.     \ Put additional response manipulations here. \
  350.  
  351.     response $cleanup
  352.     1 #responses +! ;
  353.  
  354. \ ------------------------------------------------------------
  355. \                            Part 4
  356. \ --------------------Control the program---------------------
  357.  
  358. \ ------------------create data files--\----------------------
  359. : MAKEFILES ( -- ) \ create the files if they don't exist
  360.     kwfile 0 ?fileok 0= IF               \ if keyword file isn't there
  361.       kwfile 0 newfile  kwfile open       \ create and open a data file
  362.       81 s>d <# # # # #> write  13 putchr  \ number of lines
  363.       81 1 DO
  364.         r keys  !line  9 putchr                \ send a string & tab
  365.         r 1- 2* keymap + @  s>d <# #s #> write  \ add ascii key-number
  366.         13 putchr                                \ add a cr to the end
  367.       LOOP  9 putchr 48 putchr 13 putchr  close   \ add the last line     
  368.     THEN
  369.     rsfile 0 ?fileok 0= IF          \ if response file isn't there
  370.       rsfile 0 newfile  rsfile open  \ create and open a data file
  371.       53 0 DO
  372.         r responses !line  13 putchr   \ send a string & cr
  373.       LOOP close
  374.     THEN ;
  375.  
  376. \ --------------run the program----------------
  377.  
  378. : $ELIZA ( -- output.string ) respond response ;  \ assumes instring is filled
  379. : ELIZA
  380.     makefiles
  381.     mystring $clear
  382.     ." TELL ME ABOUT IT." cr
  383.     BEGIN
  384.       instring 64 accept cr
  385.     instring ?on WHILE
  386.       $eliza 0type cr
  387.     REPEAT
  388.     ." OK THEN, G’BYE!" cr ;
  389.  
  390. -1 28 +md !
  391.